home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / sbin / update-binfmts < prev    next >
Encoding:
Text File  |  2009-09-19  |  19.9 KB  |  733 lines
  1. #! /usr/bin/perl -w
  2.  
  3. # Copyright (c) 2000, 2001, 2002 Colin Watson <cjwatson@debian.org>.
  4. # See update-binfmts(8) for documentation.
  5. #
  6. # This program is free software; you can redistribute it and/or modify
  7. # it under the terms of the GNU General Public License as published by
  8. # the Free Software Foundation; either version 2 of the License, or
  9. # (at your option) any later version.
  10. #
  11. # This program is distributed in the hope that it will be useful,
  12. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. # GNU General Public License for more details.
  15. #
  16. # You should have received a copy of the GNU General Public License
  17. # along with this program; if not, write to the Free Software
  18. # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  19.  
  20. use strict;
  21.  
  22. use POSIX qw(uname);
  23. use Text::Wrap;
  24. use Binfmt::Lib qw($admindir $importdir $procdir $auxdir $cachedir quit warning);
  25. use Binfmt::Format;
  26.  
  27. my $VERSION = '1.2.14';
  28.  
  29. $Text::Wrap::columns = 79;
  30.  
  31. use vars qw($test);
  32.  
  33. my $register = "$procdir/register";
  34. my $status = "$procdir/status";
  35. my $run_detectors = "$auxdir/run-detectors";
  36.  
  37. my %formats;
  38.  
  39. # Various "print something and exit" routines.
  40.  
  41. sub version ()
  42. {
  43.     print "update-binfmts $VERSION.\n"
  44.     or die "unable to write version message: $!";
  45. }
  46.  
  47. sub usage ()
  48. {
  49.     version;
  50.     print <<EOF
  51. Copyright (c) 2000, 2001, 2002 Colin Watson. This is free software; see
  52. the GNU General Public License version 2 or later for copying conditions.
  53.  
  54. Usage:
  55.  
  56.   update-binfmts [options] --install <name> <path> <spec>
  57.   update-binfmts [options] --remove <name> <path>
  58.   update-binfmts [options] --import [<name>]
  59.   update-binfmts [options] --display [<name>]
  60.   update-binfmts [options] --enable [<name>]
  61.   update-binfmts [options] --disable [<name>]
  62.  
  63.   where <spec> is one of:
  64.  
  65.     --magic <byte-sequence> [--mask <byte-sequence>] [--offset <offset>]
  66.     --extension <extension>
  67.  
  68.   The following argument may be added to any <spec> to have a userspace
  69.   process determine whether the file should be handled:
  70.  
  71.     --detector <path>
  72.  
  73. Options:
  74.  
  75.     --package <package-name>    for --install and --remove, specify the
  76.                                 current package name
  77.     --admindir <directory>      use <directory> instead of /var/lib/binfmts
  78.                                 as administration directory
  79.     --importdir <directory>     use <directory> instead of /usr/share/binfmts
  80.                                 as import directory
  81.     --cachedir <directory>      use <directory> instead of /var/cache/binfmts
  82.                                 as cache directory
  83.     --test                      don't do anything, just demonstrate
  84.     --help                      print this help screen and exit
  85.     --version                   output version and exit
  86.  
  87. EOF
  88.     or die "unable to write usage message: $!";
  89. }
  90.  
  91. sub usage_quit ($;@)
  92. {
  93.     my $me = $0;
  94.     $me =~ s#.*/##;
  95.     print STDERR wrap '', '', "$me:", @_, "\n";
  96.     usage;
  97.     exit 2;
  98. }
  99.  
  100. sub check_supported_os ()
  101. {
  102.     my $sysname = (uname)[0];
  103.     return if $sysname eq 'Linux';
  104.     print <<EOF;
  105. Sorry, update-binfmts currently only works on Linux.
  106. EOF
  107.     if ($sysname eq 'GNU') {
  108.     print <<EOF;
  109. Patches for Hurd support are welcomed; they should not be difficult.
  110. EOF
  111.     }
  112.     exit 2;
  113. }
  114.  
  115. # Make sure options are unambiguous.
  116.  
  117. sub check_modes ($$)
  118. {
  119.     return unless $_[0];
  120.     usage_quit "two modes given: --$_[0] and $_[1]";
  121. }
  122.  
  123. sub check_types ($$)
  124. {
  125.     return unless $_[0];
  126.     usage_quit "two binary format specifications given: --$_[0] and $_[1]";
  127. }
  128.  
  129. sub rename_mv ($$)
  130. {
  131.     my ($source, $dest) = @_;
  132.     return (rename($source, $dest) || (system('mv', $source, $dest) == 0));
  133. }
  134.  
  135. sub get_import ($)
  136. {
  137.     my $name = shift;
  138.     my %import;
  139.     local *IMPORT;
  140.     unless (open IMPORT, "< $name") {
  141.     warning "unable to open $name: $!";
  142.     return;
  143.     }
  144.     local $_;
  145.     while (<IMPORT>) {
  146.     chomp;
  147.     my ($name, $value) = split ' ', $_, 2;
  148.     $import{lc $name} = $value;
  149.     }
  150.     close IMPORT;
  151.     return %import;
  152. }
  153.  
  154. # Loading and unloading logic, which should cope with the various ways this
  155. # has been implemented.
  156.  
  157. sub get_binfmt_style ()
  158. {
  159.     my $style;
  160.     local *FS;
  161.     unless (open FS, '/proc/filesystems') {
  162.     # Weird. Assume procfs.
  163.     warning "unable to open /proc/filesystems: $!";
  164.     return 'procfs';
  165.     }
  166.     if (grep m/\bbinfmt_misc\b/, <FS>) {
  167.     # As of 2.4.3, the official Linux kernel still uses the original
  168.     # interface, but Alan Cox's patches add a binfmt_misc filesystem
  169.     # type which needs to be mounted separately. This may get into the
  170.     # official kernel in the future, so support both.
  171.     $style = 'filesystem';
  172.     } else {
  173.     # The traditional interface.
  174.     $style = 'procfs';
  175.     }
  176.     close FS;
  177.     return $style;
  178. }
  179.  
  180. sub load_binfmt_misc ()
  181. {
  182.     if ($test) {
  183.     print "load binfmt_misc\n";
  184.     return 1;
  185.     }
  186.  
  187.     my $style = get_binfmt_style;
  188.     # If the style is 'filesystem', then we must already have the module
  189.     # loaded, as binfmt_misc wouldn't show up in /proc/filesystems
  190.     # otherwise.
  191.     if ($style eq 'procfs' and not -f $register) {
  192.     if (not -x '/sbin/modprobe' or
  193.         system qw(/sbin/modprobe -q binfmt_misc)) {
  194.         warning "Couldn't load the binfmt_misc module.";
  195.         return 0;
  196.     }
  197.     }
  198.  
  199.     unless (-d $procdir) {
  200.     warning "binfmt_misc module seemed to be loaded, but no $procdir",
  201.         "directory! Giving up.";
  202.     return 0;
  203.     }
  204.  
  205.     # Find out what the style looks like now.
  206.     $style = get_binfmt_style;
  207.     if ($style eq 'filesystem' and not -f $register) {
  208.     if (system ('/bin/mount', '-t', 'binfmt_misc',
  209.             '-o', 'nodev,noexec,nosuid', 'binfmt_misc', $procdir)) {
  210.         warning "Couldn't mount the binfmt_misc filesystem on $procdir.";
  211.         return 0;
  212.     }
  213.     }
  214.  
  215.     if (-f $register) {
  216.     local *STATUS;
  217.     if (open STATUS, "> $status") {
  218.         print STATUS "1\n";
  219.         close STATUS;
  220.     } else {
  221.         warning "unable to open $status for writing: $!";
  222.     }
  223.     return 1;
  224.     } else {
  225.     warning "binfmt_misc initialized, but $register missing! Giving up.";
  226.     return 0;
  227.     }
  228. }
  229.  
  230. sub unload_binfmt_misc ()
  231. {
  232.     my $style = get_binfmt_style;
  233.  
  234.     if ($test) {
  235.     print "unload binfmt_misc ($style)\n";
  236.     return 1;
  237.     }
  238.  
  239.     if ($style eq 'filesystem') {
  240.     if (system '/bin/umount', $procdir) {
  241.         warning "Couldn't unmount the binfmt_misc filesystem from",
  242.             "$procdir.";
  243.         return 0;
  244.     }
  245.     }
  246.     # We used to try to unload the kernel module as well, but it seems that
  247.     # it doesn't always unload properly (http://bugs.debian.org/155570) and
  248.     # in any case it means that strictly speaking we have to remember if the
  249.     # module was loaded when we started. Since it's not actually important,
  250.     # we now just don't bother.
  251.     return 1;
  252. }
  253.  
  254. # Actions.
  255.  
  256. # Enable a binary format in the kernel.
  257. sub act_enable (;$);
  258. sub act_enable (;$)
  259. {
  260.     my $name = shift;
  261.     if (defined $name) {
  262.     my $cacheonly = 0;
  263.     $cacheonly = 1 unless load_binfmt_misc;
  264.     $cacheonly = 1 if -e "$procdir/$name";
  265.     unless ($test or exists $formats{$name}) {
  266.         warning "$name not in database of installed binary formats.";
  267.         return 0;
  268.     }
  269.     my $binfmt = $formats{$name};
  270.     my $type = ($binfmt->{type} eq 'magic') ? 'M' : 'E';
  271.  
  272.     my $need_detector = (defined $binfmt->{detector} and
  273.                  length $binfmt->{detector}) ? 1 : 0;
  274.     unless ($need_detector) {
  275.         # Scan the format database to see if anything else uses the same
  276.         # spec as us. If so, assume that we need a detector, effectively
  277.         # /bin/true. Don't actually set $binfmt->{detector} though,
  278.         # since run-detectors optimizes the case of empty detectors and
  279.         # "runs" them last.
  280.         for my $id (keys %formats) {
  281.         next if $id eq $name;
  282.         if ($binfmt->equals ($formats{$id})) {
  283.             $need_detector = 1;
  284.             last;
  285.         }
  286.         }
  287.     }
  288.     # Fake the interpreter if we need a userspace detector program.
  289.     my $interpreter = $need_detector ? $run_detectors
  290.                      : $binfmt->{interpreter};
  291.  
  292.     my $regstring = ":$name:$type:$binfmt->{offset}:$binfmt->{magic}" .
  293.             ":$binfmt->{mask}:$interpreter:\n";
  294.     if ($test) {
  295.         print "enable $name with the following format string:\n",
  296.           " $regstring";
  297.     } else {
  298.         local *CACHE;
  299.         if (open CACHE, ">$cachedir/$name") {
  300.             print CACHE $regstring;
  301.         close CACHE or warning "unable to close $cachedir/$name: $!";
  302.         } else {
  303.         warning "unable to open $cachedir/$name for writing: $!";
  304.         }
  305.         unless ($cacheonly) {
  306.             local *REGISTER;
  307.             unless (open REGISTER, ">$register") {
  308.             warning "unable to open $register for writing: $!";
  309.             return 0;
  310.             }
  311.             print REGISTER $regstring;
  312.             unless (close REGISTER) {
  313.              warning "unable to close $register: $!";
  314.             return 0;
  315.             }
  316.         }
  317.     }
  318.     return 1;
  319.     } else {
  320.     my $worked = 1;
  321.     for my $id (keys %formats) {
  322.         $worked &= act_enable $id;
  323.     }
  324.     return $worked;
  325.     }
  326. }
  327.  
  328. # Disable a binary format in the kernel.
  329. sub act_disable (;$);
  330. sub act_disable (;$)
  331. {
  332.     my $name = shift;
  333.     return 1 unless -d $procdir;    # We're disabling anyway, so we don't mind
  334.     if (defined $name) {
  335.     unless (-e "$procdir/$name") {
  336.         # Don't warn in this circumstance, as it could happen e.g. when
  337.         # binfmt-support and a package depending on it are upgraded at
  338.         # the same time, so we get called when stopped. Just pretend
  339.         # that the disable operation succeeded.
  340.         return 1;
  341.     }
  342.  
  343.     # We used to check the entry in $procdir to make sure we were
  344.     # removing an entry with the same interpreter, but this is bad; it
  345.     # makes things really difficult for packages that want to change
  346.     # their interpreter, for instance. Now we unconditionally remove and
  347.     # rely on the calling logic to check that the entry in $admindir
  348.     # belongs to the same package.
  349.     # 
  350.     # In other words, $admindir becomes the canonical reference, not
  351.     # $procdir. This is in line with similar update-* tools in Debian.
  352.  
  353.     if ($test) {
  354.         print "disable $name\n";
  355.     } else {
  356.         local *PROCENTRY;
  357.         unless (open PROCENTRY, ">$procdir/$name") {
  358.         warning "unable to open $procdir/$name for writing: $!";
  359.         return 0;
  360.         }
  361.         print PROCENTRY -1;
  362.         unless (close PROCENTRY) {
  363.         warning "unable to close $procdir/$name: $!";
  364.         return 0;
  365.         }
  366.         if (-e "$procdir/$name") {
  367.         warning "removal of $procdir/$name ignored by kernel!";
  368.         return 0;
  369.         }
  370.     }
  371.     return 1;
  372.     }
  373.     else
  374.     {
  375.     my $worked = 1;
  376.     for my $id (keys %formats) {
  377.         if (-e "$procdir/$id") {
  378.         $worked &= act_disable $id;
  379.         }
  380.     }
  381.     unload_binfmt_misc;    # ignore errors here
  382.     return $worked;
  383.     }
  384. }
  385.  
  386. # Install a binary format into binfmt-support's database. Attempt to enable
  387. # the new format in the kernel as well.
  388. sub act_install ($$)
  389. {
  390.     my $name = shift;
  391.     my $binfmt = shift;
  392.     if (exists $formats{$name}) {
  393.     # For now we just silently zap any old versions with the same
  394.     # package name (has to be silent or upgrades are annoying). Maybe we
  395.     # should be more careful in the future.
  396.     my $package = $binfmt->{package};
  397.     my $old_package = $formats{$name}{package};
  398.     unless ($package eq $old_package) {
  399.         $package     = '<local>' if $package eq ':';
  400.         $old_package = '<local>' if $old_package eq ':';
  401.         warning "current package is $package, but binary format already",
  402.             "installed by $old_package";
  403.         return 0;
  404.     }
  405.     unless (act_disable $name) {
  406.         warning "unable to disable binary format $name";
  407.         return 0;
  408.     }
  409.     }
  410.     if (-e "$procdir/$name" and not $test) {
  411.     # This is a bit tricky. If we get here, then the kernel knows about
  412.     # a format we don't. Either somebody has used binfmt_misc directly,
  413.     # or update-binfmts did something wrong. For now we do nothing;
  414.     # disabling and re-enabling all binary formats will fix this anyway.
  415.     # There may be a --force option in the future to help with problems
  416.     # like this.
  417.     # 
  418.     # Disabled for --test, because otherwise it never works; the
  419.     # vagaries of binfmt_misc mean that it isn't really possible to find
  420.     # out from userspace exactly what's going to happen if people have
  421.     # been bypassing update-binfmts.
  422.     warning "found manually created entry for $name in $procdir;",
  423.         "leaving it alone";
  424.     return 1;
  425.     }
  426.  
  427.     if ($test) {
  428.     print "install the following binary format description:\n";
  429.     $binfmt->dump_stdout;
  430.     } else {
  431.     $binfmt->write ("$admindir/$name.tmp") or return 0;
  432.     unless (rename_mv "$admindir/$name.tmp", "$admindir/$name") {
  433.         warning "unable to install $admindir/$name.tmp as",
  434.             "$admindir/$name: $!";
  435.         return 0;
  436.     }
  437.     }
  438.     $formats{$name} = $binfmt;
  439.     unless (act_enable $name) {
  440.     warning "unable to enable binary format $name";
  441.     return 0;
  442.     }
  443.     return 1;
  444. }
  445.  
  446. # Remove a binary format from binfmt-support's database. Attempt to disable
  447. # the format in the kernel first.
  448. sub act_remove ($$)
  449. {
  450.     my $name = shift;
  451.     my $package = shift;
  452.     unless (exists $formats{$name}) {
  453.     # There may be a --force option in the future to allow entries like
  454.     # this to be removed; either they were created manually or
  455.     # update-binfmts was broken.
  456.     warning "$admindir/$name does not exist; nothing to do!";
  457.     return 1;
  458.     }
  459.     my $old_package = $formats{$name}{package};
  460.     unless ($package eq $old_package) {
  461.     $package     = '<local>' if $package eq ':';
  462.     $old_package = '<local>' if $old_package eq ':';
  463.     warning "current package is $package, but binary format already",
  464.         "installed by $old_package; not removing.";
  465.     # I don't think this should be fatal.
  466.     return 1;
  467.     }
  468.     unless (act_disable $name) {
  469.     warning "unable to disable binary format $name";
  470.     return 0;
  471.     }
  472.     if ($test) {
  473.     print "remove $admindir/$name\n";
  474.     } else {
  475.     unless (unlink "$admindir/$name") {
  476.         warning "unable to remove $admindir/$name: $!";
  477.         return 0;
  478.     }
  479.     delete $formats{$name};
  480.     unlink "$cachedir/$name";
  481.     }
  482.     return 1;
  483. }
  484.  
  485. # Import a new format file into binfmt-support's database. This is intended
  486. # for use by packaging systems.
  487. sub act_import (;$);
  488. sub act_import (;$)
  489. {
  490.     my $name = shift;
  491.     if (defined $name) {
  492.     my $id;
  493.     if ($name =~ m!.*/(.*)!) {
  494.         $id = $1;
  495.     } else {
  496.         $id = $name;
  497.         $name = "$importdir/$name";
  498.     }
  499.  
  500.     if ($id =~ /^(\.\.?|register|status)$/) {
  501.         warning "binary format name '$id' is reserved";
  502.         return 0;
  503.     }
  504.  
  505.     my %import = get_import $name;
  506.     unless (scalar keys %import) {
  507.         warning "couldn't find information about '$id' to import";
  508.         return 0;
  509.     }
  510.  
  511.     if (exists $formats{$id}) {
  512.         if ($formats{$id}{package} eq ':') {
  513.         # Installed version was installed manually, so don't import
  514.         # over it.
  515.         warning "preserving local changes to $id";
  516.         return 1;
  517.         } else {
  518.         # Installed version was installed by a package, so it should
  519.         # be OK to replace it.
  520.         }
  521.     }
  522.  
  523.     # TODO: This duplicates the verification code below slightly.
  524.     unless (defined $import{package}) {
  525.         warning "$name: required 'package' line missing";
  526.         return 0;
  527.     }
  528.  
  529.     unless (-x $import{interpreter}) {
  530.         warning "$name: no executable $import{interpreter} found, but",
  531.             "continuing anyway as you request";
  532.     }
  533.  
  534.     act_install $id, Binfmt::Format->new ($name, %import);
  535.     return 1;
  536.     } else {
  537.     local *IMPORTDIR;
  538.     unless (opendir IMPORTDIR, $importdir) {
  539.         warning "unable to open $importdir: $!";
  540.         return 0;
  541.     }
  542.     my $worked = 1;
  543.     for (readdir IMPORTDIR) {
  544.         next unless -f "$importdir/$_";
  545.         if (-f "$importdir/$_") {
  546.         $worked &= act_import $_;
  547.         }
  548.     }
  549.     closedir IMPORTDIR;
  550.     return $worked;
  551.     }
  552. }
  553.  
  554. # Display a format stored in binfmt-support's database.
  555. sub act_display (;$);
  556. sub act_display (;$)
  557. {
  558.     my $name = shift;
  559.     if (defined $name) {
  560.     print "$name (", (-e "$procdir/$name" ? 'enabled' : 'disabled'),
  561.           "):\n";
  562.     my $binfmt = $formats{$name};
  563.     my $package = $binfmt->{package} eq ':' ? '<local>'
  564.                         : $binfmt->{package};
  565.     print <<EOF;
  566.      package = $package
  567.         type = $binfmt->{type}
  568.       offset = $binfmt->{offset}
  569.        magic = $binfmt->{magic}
  570.         mask = $binfmt->{mask}
  571.  interpreter = $binfmt->{interpreter}
  572.     detector = $binfmt->{detector}
  573. EOF
  574.     } else {
  575.     for my $id (keys %formats) {
  576.         act_display $id;
  577.     }
  578.     }
  579.     return 1;
  580. }
  581.  
  582. # Now go.
  583.  
  584. check_supported_os;
  585.  
  586. my @modes = qw(install remove import display enable disable);
  587. my @types = qw(magic extension);
  588.  
  589. my ($package, $name);
  590. my ($mode, $type);
  591. my %spec;
  592.  
  593. my %unique_options = (
  594.     'package'    => \$package,
  595.     'mask'    => \$spec{mask},
  596.     'offset'    => \$spec{offset},
  597.     'detector'  => \$spec{detector},
  598. );
  599.  
  600. my %arguments = (
  601.     'admindir'    => ['path' => \$admindir],
  602.     'importdir'    => ['path' => \$importdir],
  603.     'cachedir'    => ['path' => \$cachedir],
  604.     'install'    => ['name' => \$name, 'path' => \$spec{interpreter}],
  605.     'remove'    => ['name' => \$name, 'path' => \$spec{interpreter}],
  606.     'package'    => ['package-name' => \$package],
  607.     'magic'    => ['byte-sequence' => \$spec{magic}],
  608.     'extension'    => ['extension' => \$spec{extension}],
  609.     'mask'    => ['byte-sequence' => \$spec{mask}],
  610.     'offset'    => ['offset' => \$spec{offset}],
  611.     'detector'  => ['path' => \$spec{detector}],
  612. );
  613.  
  614. my %parser = (
  615.     'help'    => sub { usage; exit 0; },
  616.     'version'    => sub { version; exit 0; },
  617.     'test'    => sub { $test = 1; },
  618.     'install'    => sub {
  619.     -x $spec{interpreter}
  620.         or warning "no executable $spec{interpreter} found, but",
  621.                "continuing anyway as you request";
  622.     },
  623.     'remove'    => sub {
  624.     -x $spec{interpreter}
  625.         or warning "no executable $spec{interpreter} found, but",
  626.                "continuing anyway as you request";
  627.     },
  628.     'import'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  629.     'display'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  630.     'enable'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  631.     'disable'    => sub { $name = (@ARGV >= 1) ? shift @ARGV : undef; },
  632.     'offset'    => sub {
  633.     $spec{offset} =~ /^\d+$/
  634.         or usage_quit 'offset must be a whole number';
  635.     },
  636.     'detector'  => sub {
  637.     -x $spec{detector}
  638.         or warning "no executable $spec{detector} found, but",
  639.                "continuing anyway as you request";
  640.     },
  641. );
  642.  
  643. while (defined($_ = shift))
  644. {
  645.     last if /^--$/;
  646.     if (!/^--(.+)$/) {
  647.     usage_quit "unknown argument '$_'";
  648.     }
  649.     my $option = $1;
  650.     my $is_mode = grep { $_ eq $option } @modes;
  651.     my $is_type = grep { $_ eq $option } @types;
  652.     my $has_args = exists $arguments{$option};
  653.  
  654.     unless ($is_mode or $is_type or $has_args or exists $parser{$option}) {
  655.     usage_quit "unknown argument '$_'";
  656.     }
  657.  
  658.     check_modes $mode, $option if $is_mode;
  659.     check_types $type, $option if $is_type;
  660.  
  661.     if (exists $unique_options{$option} and
  662.     defined ${$unique_options{$option}}) {
  663.     usage_quit "more than one --$option option given";
  664.     }
  665.  
  666.     if ($has_args) {
  667.     my (@descs, @varrefs);
  668.     # Split into descriptions and variable references.
  669.     my $alt = 0;
  670.     foreach my $arg (@{$arguments{$option}}) {
  671.         if (($alt = !$alt))    { push @descs, "<$arg>"; }
  672.         else        { push @varrefs, $arg; }
  673.     }
  674.     usage_quit "--$option needs @descs" unless @ARGV >= @descs;
  675.     foreach my $varref (@varrefs) { $$varref = shift @ARGV; }
  676.     }
  677.  
  678.     &{$parser{$option}} if defined $parser{$option};
  679.  
  680.     $mode = $option if $is_mode;
  681.     $type = $option if $is_type;
  682. }
  683.  
  684. $package = ':' unless defined $package;
  685.  
  686. unless (defined $mode) {
  687.     usage_quit 'you must use one of --install, --remove, --import, --display,',
  688.            '--enable, --disable';
  689. }
  690.  
  691. my $binfmt;
  692. if ($mode eq 'install') {
  693.     defined $type or usage_quit '--install requires a <spec> option';
  694.     if ($name =~ /^(\.\.?|register|status)$/) {
  695.     usage_quit "binary format name '$name' is reserved";
  696.     }
  697.     $binfmt = Binfmt::Format->new ($name, package => $package, type => $type,
  698.                    %spec);
  699. }
  700.  
  701. local *ADMINDIR;
  702. unless (opendir ADMINDIR, $admindir) {
  703.     quit "unable to open $admindir: $!";
  704. }
  705. for my $name (readdir ADMINDIR) {
  706.     if (-f "$admindir/$name") {
  707.     my $format = Binfmt::Format->load ($name, "$admindir/$name");
  708.     $formats{$name} = $format if defined $format;
  709.     }
  710. }
  711. closedir ADMINDIR;
  712.  
  713. my %actions = (
  714.     'install'    => [\&act_install, $binfmt],
  715.     'remove'    => [\&act_remove, $package],
  716.     'import'    => [\&act_import],
  717.     'display'    => [\&act_display],
  718.     'enable'    => [\&act_enable],
  719.     'disable'    => [\&act_disable],
  720. );
  721.  
  722. unless (exists $actions{$mode}) {
  723.     usage_quit "unknown mode: $mode";
  724. }
  725.  
  726. my @actargs = @{$actions{$mode}};
  727. my $actsub = shift @actargs;
  728. if ($actsub->($name, @actargs)) {
  729.     exit 0;
  730. } else {
  731.     quit 'exiting due to previous errors';
  732. }
  733.